
Attribute VB_Name = "callBack"
' 本次主要升级
'  1.自动设置个万亿
'  2.多单元格内容合并功能
'  3.破解工作表保护功能
'  4.破解工作簿保护功能
'  5.批量调整行高列宽功能(窗体)
'  6.新增工作表排序功能
'  7.查询身份证信息时的窗体，允许复制内容(窗体)

' 为精简代码，过往功能请查看之前的文章

Option Explicit

' 自动设置个万亿
Sub digitalAuto(control As IRibbonControl)
    Dim rng As Range
    For Each rng In Selection.Cells
        If Abs(rng.Value) < 10 ^ 4 Then
            rng.NumberFormatLocal = "0"
        ElseIf Abs(rng.Value) < 10 ^ 8 Then
            rng.NumberFormatLocal = "0!.0,""万"""
        Else
            rng.NumberFormatLocal = "0!.00,,""亿"""
        End If
    Next
    Selection.VerticalAlignment = xlTop
End Sub


' 会自动清除非首个单元格
' 所有内容以文本格式写在首个单元格内
Sub mergeCellsContent(control As IRibbonControl)
    With Selection
        Dim v As Variant
        v = .Cells(1).Value
        Dim i As Long
        If .Count > 1 Then
            For i = 2 To .Cells.Count
                v = v & .Cells(i).Value
                .Cells(i).ClearContents ' 可以使用定位空单元格继续下一步操作
            Next
        End If
        .Cells(1).Value = v
    End With
End Sub


Sub sortSheet(control As IRibbonControl)

    ' 尝试删除原有的排序工作表
    On Error Resume Next
    Excel.Application.DisplayAlerts = False
    Worksheets("浅北工作表排序").Delete
    Excel.Application.DisplayAlerts = True
    On Error GoTo 0

    ' 获取当前工作簿所有工作表的名称，包括隐藏的工作表
    Dim shtNameList() As String
    ReDim shtNameList(1 To ActiveWorkbook.Worksheets.Count, 1 To 1)

    Dim sht As Worksheet
    Dim i As Long: i = 1
    For Each sht In ActiveWorkbook.Worksheets
        shtNameList(i, 1) = sht.Name
        i = i + 1
    Next


    ' 新建工作表并写入工作表名称
    Dim listSht As Worksheet
    Set listSht = Worksheets.Add

    listSht.Name = "浅北工作表排序" ' 设置唯一名称，之后容易删除
    listSht.Select
    listSht.Range("A1").Value = "工作表名称"
    listSht.Range("A2").Resize(UBound(shtNameList), 1).Value = shtNameList

    ' 创建按钮
    With listSht.Buttons.Add(180, 24, 100, 40)
        .OnAction = "startSortSheet"
        .Characters.text = "开始排序"
        With .Characters(Start:=1, Length:=4).Font
            .Name = "微软雅黑"
            .FontStyle = "常规"
            .SIZE = 11
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = 1
        End With
    End With

    ' 添加排序筛选按钮
    listSht.Range("A1").CurrentRegion.AutoFilter
End Sub
' 点击按钮后执行的程序
Sub startSortSheet()
    Dim arr
    With Worksheets("浅北工作表排序")
        ' 获取排序后的工作表
        arr = .Range(.Range("A2"), .Range("A2").End(xlDown)).Value

        Dim i As Long
        For i = LBound(arr) To UBound(arr)
            Worksheets(arr(i, 1)).Move before:=Worksheets(i + 1)
        Next

        ' 删除此工作表
        Excel.Application.DisplayAlerts = False
        .Delete
        Excel.Application.DisplayAlerts = True

    End With
End Sub


' 破解工作表保护
Sub crackWorkSheetsProtection(control As IRibbonControl)
    ' 用于单元格无法修改

    If MsgBox("如果单元格无法修改可使用此功能！" & Chr(13) & "此功能仅限于自己的文件忘记密码时使用，勿做他用", vbOKCancel + vbCritical) = vbOK Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        On Error Resume Next
        Dim sht As Worksheet
        For Each sht In Worksheets
            ' 需要设置密码为""，否则会弹窗提示录入密码
            sht.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
            sht.Protect Password:="", DrawingObjects:=False, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True
            sht.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True
            sht.Protect Password:="", DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
            sht.Unprotect Password:=""
        Next
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        MsgBox "密码已被取消"
    End If
End Sub

' 破解工作簿保护
Sub crackWorkbookProtection(control As IRibbonControl)
    ' MsgBox "此功能并非破解密码，而是会创建一个新文件，将原文件内容拷贝过来"
    ActiveWorkbook.Sheets.Copy
    Dim sht As Worksheet
    For Each sht In ActiveWorkbook.Sheets
        sht.Visible = True
    Next
End Sub

